(*
  Copyright (c) 2009 Barry Schwartz

  Permission is hereby granted, free of charge, to any person
  obtaining a copy of this software and associated documentation
  files (the "Software"), to deal in the Software without
  restriction, including without limitation the rights to use,
  copy, modify, merge, publish, distribute, sublicense, and/or sell
  copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following
  conditions:

  The above copyright notice and this permission notice shall be
  included in all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
  OTHER DEALINGS IN THE SOFTWARE.
*)

open Dim
open FontForge
open GlyphMetric
open Graphic
open OpenType
open Substitute
open UniTools
open UTypes
open XNum

(* font metrics *)
type font_parameter = {
  hyphen_glyph : glyph_desc;
  skew_glyph : glyph_desc;
  margin_glyph : glyph_desc;
  space_glyph : glyph_desc;
  foreign_glyph : glyph_desc;
  slant : num;
  space : num;
  space_stretch : num;
  space_shrink : num;
  x_height : num;
  quad : num;
  extra_space : num;
  num_shift_1 : num;
  num_shift_2 : num;
  num_shift_3 : num;
  denom_shift_1 : num;
  denom_shift_2 : num;
  super_shift_1 : num;
  super_shift_2 : num;
  super_shift_3 : num;
  sub_shift_1 : num;
  sub_shift_2 : num;
  super_drop : num;
  sub_drop : num;
  delim_1 : num;
  delim_2 : num;
  axis_height : num;
  rule_thickness : num;
  big_op_spacing_1 : num;
  big_op_spacing_2 : num;
  big_op_spacing_3 : num;
  big_op_spacing_4 : num;
  big_op_spacing_5 : num
} (* with sexp_of *)

type font_type = | OpenTypeCFF | TrueType | TFM | Other (* with sexp_of *)

type font_metric = {
  id : string;                       (* Unique internal identifier. *)
  name : string;
  ps_name : string;
  file_name : UniText.t;
  font_type : font_type;
  first_glyph : int;
  last_glyph : int;
  design_size : num;
  at_size : num;
  check_sum : num;
  parameter : font_parameter;
  get_glyph : uc_char -> glyph_desc;
  get_unicode : glyph_desc -> uc_string;
  get_composer : 'box 'cmd . ('box, 'cmd) get_composer_type;
  kerning : font_metric -> int -> int -> lig_kern;
  draw_simple_glyph : font_metric -> int -> glyph_text -> simple_box;
  accent_base_point : font_metric -> glyph_metric -> (num * num);
  accent_attach_point : font_metric -> glyph_metric -> (num * num);
  get_glyph_bitmap : font_metric -> uc_char -> GlyphBitmap.glyph;
  get_glyph_name : int -> string;
  get_glyph_index : string -> int;
  code_to_glyph_index : int -> int;
  glyph_name_to_code : string -> int;
  glyph_metric : glyph_metric array;
  ff_font : FFfont.t option;
}

and ('box, 'cmd) get_composer_type =
    font_metric -> UniText.t -> FeatureSet.t -> (font_metric, 'box, 'cmd) glyph_composer

and simple_box =
  | Empty
  | SimpleGlyph of int * font_metric * glyph_text
  | Rule of num * num
  | Image of num * num * string
  | Group of ((num, simple_box) graphic_command) list
  | Command of simple_cmd

and simple_cmd =
    [
    | `DVI_Special of string
    | `PDF_Code of string
    | `PDF_Info of pdf_object   (* pdf_object should be a `PDF_Dict *)
    | `PDF_Catalog of pdf_object (* pdf_object should be a `PDF_Dict *)
    | `PDF_Register of pdf_object * int
    ]

and pdf_object =
    [
    | `PDF_Null
    | `PDF_Name of UniText.t
    | `PDF_String of UniText.t
    | `PDF_Bool of bool
    | `PDF_Int of int
    | `PDF_Real of num
    | `PDF_Array of pdf_object list
    | `PDF_Dict of (UniText.t * pdf_object) list
    | `PDF_Indirect of pdf_object
    | `PDF_Unencrypted of pdf_object
    | `PDF_Uncompressed of pdf_object
    | `PDF_ByteStream of pdf_object * string
    | `PDF_FileStream of pdf_object * UniText.t
    | `PDF_ImageStream of UniText.t
    | `PDF_Reference of int
    ]

(* with sexp_of *)

(*
let sexp_of_font_metric _fm = Sexp.of_string "<font_metric>"
*)

type glyph_spec =
  | GlyphIndex of int | GlyphChar of uc_char | GlyphName of string

type adjustment_spec = | AdjKern of num | AdjLig of glyph_spec

module GlyphSpecTrie =
  DynamicTrie.Make(struct
                     type t = glyph_spec
                     let compare = compare
                   end)
  
(* User specified modifications of font parameters. *)
type font_load_params = {
  flp_size : num;                    (* scale font to this size     *)
  flp_encoding : uc_string array;    (* overrides built in encoding *)

  (* FIX: replace these two by a complete font_parameter *)
  flp_hyphen_glyph : glyph_desc;     (* specifies the hyphen glyph  *)
  flp_skew_glyph : glyph_desc;       (* specifies the skew glyph    *)

  flp_letter_spacing : num;          (* additional letter spacing   *)
  flp_extra_pos : adjustment_spec GlyphSpecTrie.t; (* additional kerning pairs and ligatures *)
  flp_extra_subst : adjustment_spec GlyphSpecTrie.t; (* additional kerning pairs and ligatures *)
  flp_extra_kern : (glyph_spec * extra_kern_info) list (* kerning with border glyphs *)
}

(* pages *)
type page = {
  p_contents : simple_box;
  p_number : int;
  p_width : num;
  p_height : num;
}

(* resolution used to load bitmap fonts *)
let default_bitmap_resolution = ref 1200
  
let default_mf_mode = ref "ljfzzz"

let fontmetric_counter = ref 0
let new_fontmetric_id () =
  fontmetric_counter := !fontmetric_counter + 1;
  string_of_int !fontmetric_counter
  
(* |get_glyph <font> <char>| returns the glyph corresponding to the unicode <char> and
   |get_unicode <font> <glyph>| computes the unicode of the given glyph.
*)
let get_glyph font char = font.get_glyph char
  
let get_unicode font glyph = font.get_unicode glyph
  
(* |glyph_exists <font> <glyph>| tests whether the font contains a glyph with the number <glyph>. *)
let glyph_exists font glyph =
  (glyph <= font.last_glyph) && (glyph >= font.first_glyph)
  
(* |glyph_spec_to_index <lookup-char> <lookup-name> <spec>| translates a |glyph_spec|
   into the corresponding glyph index.
*)
let glyph_spec_to_index lookup_char lookup_name spec =
  match spec with
    | GlyphIndex x -> x
    | GlyphChar  x -> lookup_char x
    | GlyphName  x -> lookup_name x
  
(*
  |index_to_glyph <font> <index>| checks whether <font> contains a glyph of the given index and returns
  the corresponding |glyph_desc|.
*)
let index_to_glyph font idx =
  if glyph_exists font idx then
    Simple idx
  else
    Undef
  
(*
  |accent_base_point <font> <glyph-metric>| returns the point where the glyph is attached to another glyph
  when it is used as an accent.
*)
let accent_base_point font gm = font.accent_base_point font gm
  
(*
  |accent_attach_point <font> <glyph-metric>| returns the point where an accent should be attached
  to the glyph.
*)
let accent_attach_point font gm = font.accent_attach_point font gm
  
(*
  |accent_position <acc-font> <acc-gm> <chr-font> <chr-gm>| calculates the position of the accent glyph
  in a composite glyph.
*)
let accent_position acc_font acc_gm chr_font chr_gm =
  let (acc_x, acc_y) = accent_base_point acc_font acc_gm in
  let (chr_x, chr_y) = accent_attach_point chr_font chr_gm
  in
    (*  let pos_y  = chr_gm.gm_height -/ acc_font.parameter.x_height;
  let pos_x  = (chr_gm.gm_width -/ acc_gm.gm_width) // num_of_int 2
               +/ (chr_font.parameter.slant */ chr_gm.gm_height
               -/ acc_font.parameter.slant */ acc_font.parameter.x_height);*)
    ((sub_num chr_x acc_x), (sub_num chr_y acc_y))
  
let rec get_glyph_metric font glyph =
  match glyph with
    | Undef -> empty_glyph_metric
    | Simple g -> font.glyph_metric.(g - font.first_glyph)
    | Raised (g, _) -> font.glyph_metric.(g - font.first_glyph)
    | Accent (a, g) -> construct_accent font (Simple a) font (Simple g)
    | Sequence gs -> construct_sequence font gs
    | Extendable (t, m, b, _) ->
        let tgm = get_glyph_metric font t in
        let mgm = get_glyph_metric font m in
        let bgm = get_glyph_metric font b in
          { gm_width = max_num tgm.gm_width (max_num mgm.gm_width bgm.gm_width);
            gm_height = add_num (add_num tgm.gm_height tgm.gm_depth) mgm.gm_height;
            gm_depth = add_num (add_num mgm.gm_depth bgm.gm_height) bgm.gm_depth;
            gm_italic = num_zero;
            gm_extra = GXI_Normal;
            gm_extra_kern = zero_kern_info }

and
    (*
      |construct_accent <acc-font> <acc> <chr-font> <chr>| constructs a glyph_metric structure for the
      composite glyph.
    *)
    construct_accent acc_font acc chr_font chr =
  let acc_gm = get_glyph_metric acc_font acc in
  let chr_gm = get_glyph_metric chr_font chr in
  let (_, pos_y) = accent_position acc_font acc_gm chr_font chr_gm in
    { chr_gm with
        gm_height = max_num chr_gm.gm_height (add_num acc_gm.gm_height pos_y);
        gm_depth = max_num chr_gm.gm_depth (sub_num acc_gm.gm_depth pos_y) }

and construct_sequence font glyphs =
  match glyphs with
    | [] -> empty_glyph_metric
    | [ g ] -> get_glyph_metric font (Simple g)
    | first :: gs ->
        let m1 = get_glyph_metric font (Simple first) in
        let rec iter width height depth glyphs =
          (match glyphs with
             | [ last ] ->
                 let m2 = get_glyph_metric font (Simple last)
                 in
                   {
                     gm_width = add_num width m2.gm_width;
                     gm_height = max_num height m2.gm_height;
                     gm_depth = max_num depth m2.gm_depth;
                     gm_italic = m2.gm_italic;
                     gm_extra = GXI_Normal;
                     gm_extra_kern =
                       merge_kern_infos m1.gm_extra_kern m2.gm_extra_kern;
                   }
             | g :: gs ->
                 let m = get_glyph_metric font (Simple g)
                 in
                   iter (add_num width m.gm_width) (max_num height m.gm_height)
                     (max_num depth m.gm_depth) gs
             | [] -> assert false)
        in
          iter m1.gm_width m1.gm_height m1.gm_depth gs
  
(* Default value for |accent_base_point| where the base point lies at the x-height. *)
let accent_base_point_x_height font gm =
  let pos_x =
    add_num (div_num gm.gm_width (num_of_int 2))
      (mult_num font.parameter.slant font.parameter.x_height)
  in
    (pos_x, font.parameter.x_height)
  
(* Default value for |accent_attach_point| where the accent is attached to the top of the glyph. *)
let accent_attach_point_top font gm =
  let pos_x =
    add_num (div_num gm.gm_width (num_of_int 2))
      (mult_num font.parameter.slant gm.gm_height)
  in (pos_x, (gm.gm_height))
  
(*
  |next_glyph <font> <glyph>| returns the next variant of a character, or |Undef| if there is none.
*)
let next_glyph font glyph =
  match (get_glyph_metric font glyph).gm_extra with
  | GXI_List n ->
      (match (get_glyph_metric font (Simple n)).gm_extra with
       | GXI_Extendable (t, m, b, r) ->
           Extendable (Simple t, Simple m, Simple b, Simple r)
       | _ -> Simple n)
  | _ -> Undef
  
(*
  |get_lig_kern <font> <glyph-1> <glyph-2>| returns either the amount of kerning between two glyphs
  or the ligature formed by them.
*)
let get_lig_kern font glyph1 glyph2 =
  match (glyph1, glyph2) with
    | (Simple g1, Simple g2) -> font.kerning font g1 g2
    | (Simple g1, Accent (_, g2)) -> font.kerning font g1 g2
    | (Accent (_, g1), Simple g2) -> font.kerning font g1 g2
    | (Accent (_, g1), Accent (_, g2)) -> font.kerning font g1 g2
    | _ -> NoLigKern
  
let get_glyph_composer font script features =
  font.get_composer font script features
      
(* Default value for |draw_simple_glyph|. *)
let draw_simple_glyph font glyph text = SimpleGlyph (glyph, font, text)
  
(* Variant of |draw_simple_glyph| that allows for displacing the glyph by some amount. *)
let draw_displaced_simple_glyph dx dy font glyph text =
  Group [Graphic.PutBox (dx, dy, SimpleGlyph (glyph, font, text))]
  
let rec draw_glyph font glyph text =
  match glyph with
    | Undef -> Empty

    | Simple g ->
        (* <g> might be a non-existing glyph index, indicating e.g. a border glyph *)
        if g >= font.first_glyph && g <= font.last_glyph then
          font.draw_simple_glyph font g text
        else
          Empty

    | Raised (g, d) ->
        (* <g> might be a non-existing glyph index, indicating e.g. a border glyph *)
        if g >= font.first_glyph && g <= font.last_glyph then
          draw_displaced_simple_glyph num_zero d font g text
        else
          Empty

    | Accent (a, g) ->
        let a_gm = get_glyph_metric font (Simple a) in
        let g_gm = get_glyph_metric font (Simple g) in
        let (pos_x, pos_y) = accent_position font a_gm font g_gm in
          Group
            [Graphic.PutBox (num_zero, num_zero, draw_glyph font (Simple g) text);
             Graphic.PutBox (pos_x, pos_y, draw_glyph font (Simple a) text)]

    | Sequence gs ->
        let cmds = ListBuilder.make () in
        let rec iter x glyphs =
          match glyphs with
            | [] -> Group (ListBuilder.get cmds)
            | g :: gs ->
                let m = get_glyph_metric font (Simple g) in
                  ListBuilder.add cmds (Graphic.PutBox (x, num_zero, draw_glyph font (Simple g) text));
                  iter (add_num x m.gm_width) gs
        in
          iter num_zero gs

    | Extendable (t, m, b, _) ->
        let tgm = get_glyph_metric font t in
        let mgm = get_glyph_metric font m in
        let bgm = get_glyph_metric font b in
          Group
            [Graphic.PutBox (num_zero, add_num tgm.gm_depth mgm.gm_height,
                             draw_glyph font t text);
             Graphic.PutBox (num_zero, num_zero, draw_glyph font m text);
             Graphic.PutBox (num_zero, add_num mgm.gm_depth bgm.gm_height,
                             draw_glyph font b text)]
  
let get_hyphen_glyph fm = fm.parameter.hyphen_glyph
let get_skew_glyph fm = fm.parameter.skew_glyph
  
(* Shorthand to access the dimension of a normal and an extended space of the font. *)
let space_glue font = {
  d_base = font.parameter.space;
  d_stretch_factor = font.parameter.space_stretch;
  d_stretch_order = 0;
  d_shrink_factor = font.parameter.space_shrink;
  d_shrink_order = 0;
}
  
let xspace_glue font = {
  d_base = add_num font.parameter.space font.parameter.extra_space;
  d_stretch_factor = font.parameter.space_stretch;
  d_stretch_order = 0;
  d_shrink_factor = font.parameter.space_shrink;
  d_shrink_order = 0;
}
  
let empty_parameter = {
  hyphen_glyph = Undef;
  skew_glyph = Undef;
  margin_glyph = Undef;
  space_glyph = Undef;
  foreign_glyph = Undef;
  slant = num_zero;
  space = num_zero;
  space_stretch = num_zero;
  space_shrink = num_zero;
  x_height = num_zero;
  quad = num_zero;
  extra_space = num_zero;
  num_shift_1 = num_zero;
  num_shift_2 = num_zero;
  num_shift_3 = num_zero;
  denom_shift_1 = num_zero;
  denom_shift_2 = num_zero;
  super_shift_1 = num_zero;
  super_shift_2 = num_zero;
  super_shift_3 = num_zero;
  sub_shift_1 = num_zero;
  sub_shift_2 = num_zero;
  super_drop = num_zero;
  sub_drop = num_zero;
  delim_1 = num_zero;
  delim_2 = num_zero;
  axis_height = num_zero;
  rule_thickness = num_zero;
  big_op_spacing_1 = num_zero;
  big_op_spacing_2 = num_zero;
  big_op_spacing_3 = num_zero;
  big_op_spacing_4 = num_zero;
  big_op_spacing_5 = num_zero;
}
  
let empty_font = {
  id = new_fontmetric_id ();
  name = "<null>";
  ps_name = "";
  file_name = UniText.of_string "<internal>";
  font_type = Other;
  first_glyph = 0;
  last_glyph = (-1);
  design_size = num_one;
  at_size = num_one;
  check_sum = num_zero;
  get_glyph = (fun _ -> Undef);
  get_unicode = (fun _ -> [|  |]);
  kerning = (fun _ -> assert false);
  get_composer = (fun _ _ _ i -> i);
  draw_simple_glyph = (fun _ _ _ -> Empty);
  accent_base_point = (fun _ -> assert false);
  accent_attach_point = (fun _ -> assert false);
  get_glyph_bitmap = (fun _ -> assert false);
  get_glyph_name = (fun _ -> assert false);
  get_glyph_index = (fun _ -> assert false);
  code_to_glyph_index = (fun _ -> assert false);
  glyph_name_to_code = (fun _ -> assert false);
  glyph_metric = [|  |];
  parameter = empty_parameter;
  ff_font = None;
}
  
let empty_load_params = {
  flp_size = num_zero;
  flp_encoding = [|  |];
  flp_hyphen_glyph = Undef;
  flp_skew_glyph = Undef;
  flp_letter_spacing = num_zero;
  flp_extra_pos = GlyphSpecTrie.empty;
  flp_extra_subst = GlyphSpecTrie.empty;
  flp_extra_kern = [];
}

(*-----------------------------------------------------------------------*)

let ff_fonts_that_are_open = Hashtbl.create 5

let get_opened_ff_font file_name =
  try
    let (font, ref_count) =  Hashtbl.find ff_fonts_that_are_open file_name in
      Hashtbl.replace ff_fonts_that_are_open file_name (font, ref_count + 1);
      font
  with
    | Not_found ->
        let font = FFfont.open_file (UniText.to_string file_name) in
          Hashtbl.add ff_fonts_that_are_open file_name (font, 1);
          font

let quit_using_ff_font file_name =
  let (font, ref_count) = Hashtbl.find ff_fonts_that_are_open file_name in
    if ref_count = 1 then
      FFfont.close font
    else
      Hashtbl.replace ff_fonts_that_are_open file_name (font, ref_count - 1)

(*-----------------------------------------------------------------------*)
